#!/usr/bin/perl -c

package PIPL::IO::Handle;
use 5.006;
our $VERSION = '0.01';

=head1 NAME

PIPL::IO::Handle - Reimplementation of IO::Handle

=head1 SYNOPSIS

  use PIPL::IO::Handle;

  $fh = IO::Handle->new;
  $fh->fdopen(fileno(STDIN));
  print $fh->getline;
  $file = $fh->slurp;
  $fh->close;

  $fh = fdopen IO::Handle \*STDERR, '>';
  autoflush $fh 1;
  say $fh 'Some text';
  undef $fh;  # calls close at DESTROY

=head1 DESCRIPTION

This class provides an interface mostly compatible with L<IO::Handler>.  The
differences:

=over

=item *

Its base class is a L<PIPL::Class::Base> so it uses referenced hash as a
container.

=item *

It uses L<Exception::Base> for signaling errors.

=item *

The modifiers like B<input_record_separator> are supported on per-filehandler
basis.

=item *

It also implements additional methods like B<say>, B<slurp>.

=item *

It is pure-Perl implementation.

=back

=cut


use strict;

use base 'PIPL::Class::Base';


use Exception::Base
    'Exception::IO' => { isa => 'Exception::System' },
    'Exception::Runtime' => { isa => 'Exception::Base' },
    'Exception::BadValue' => { isa => 'Exception::Base' };


use Scalar::Util 'blessed', 'reftype', 'weaken';
use Symbol 'qualify';


# List of class fields (name => {is=>ro|rw, default=>value})
use constant FIELDS => {
    fh            => { is => 'ro' },
    tied_fh       => { is => 'ro' },
    fd            => { is => 'rw' },
    mode          => { is => 'rw', default => '<' },
    autochomp     => { is => 'rw' },
    ungetc_buffer => { is => 'ro' },
    format_line_break_characters => { is => 'rw' },
    format_formfeed              => { is => 'rw' },
    input_record_separator       => { is => 'rw' },
    output_field_separator       => { is => 'rw' },
    output_record_separator      => { is => 'rw' },
};


# Constant for PIPL::IO::Handle::Tie package name
sub __TIEPACKAGE__ () { __PACKAGE__ . '::Tie' };


# Debugging flag
our $Debug = 1;


# Default constructor
sub new {
    warn "new @_" if $Debug;

    my $class = shift;
    $class = ref $class if ref $class;

    my $self = $class->SUPER::new(@_);

    # initialize anonymous handlers
    $self->{fh} = __PACKAGE__->anonio;
    $self->{tied_fh} = __TIEPACKAGE__->anonio;

    if (defined $self->{fd}) {
        # call fdopen if fd is defined, it's also tie handler
        $self->fdopen($self->{fd}, $self->{mode});

        # break circular reference, now fd is for informational reason only
        weaken $self->{fd} if ref $self->{fd};
    }
    else {
        # tie handler with proxy class just here
        tie *{ $self->{tied_fh} }, __TIEPACKAGE__, $self;
    }

    # create object from tied fh
    my $tied_fh = $self->{tied_fh};
    weaken $self->{tied_fh};
    ${*$tied_fh} = $self;
    return bless $tied_fh => $class;
}


# fdopen constructor
sub new_from_fd {
    warn "new_from_fd @_" if $Debug;

    my $class = shift;
    $class = ref $class if ref $class;

    my $fd = shift;
    my $mode = shift;

    return $class->new(fd => $fd, mode => $mode);
}


# fdopen method
sub fdopen {
    warn "fdopen @_" if $Debug;

    my $self = shift;
    return $self->new_from_fd(@_) unless ref $self;  # called as constructor

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    my $fd = shift;
    throw Exception::BadValue
          message => 'Usage: ' . __PACKAGE__ . '->fdopen(FD, [MODE])'
        if not defined $fd;

    my $mode = shift;
    $mode = $self->{defaults}->{mode} if not defined $mode;

    throw Exception::BadValue
          message => "Bad open mode: $mode"
        unless ($mode =~ /^\+?(<|>>?)$/
            or $mode =~ s/^r(\+?)$/$1</
            or $mode =~ s/^w(\+?)$/$1>/
            or $mode =~ s/^a(\+?)$/$1>>/);

    $self->{mode} = $mode;

    my $status;
    if (blessed $fd and $fd->isa(__PACKAGE__)) {
        warn "fdopen: open(fh, $mode&, \$fd->{tied_fh})\n" if $Debug;
        $status = open($self->{fh}, "$mode&", ${*$fd}->{tied_fh});
    }
    elsif (ref $fd eq 'GLOB') {
        warn "fdopen: open(fh, $mode&, \\$$fd)\n" if $Debug;
        $status = open($self->{fh}, "$mode&", $fd);
    }
    elsif (reftype $fd eq 'GLOB') {
        warn "fdopen: open(fh, $mode&, *$fd)\n" if $Debug;
        $status = open($self->{fh}, "$mode&", *$fd);
    }
    elsif ($fd =~ /^\d+$/) {
        warn "fdopen: open(fh, $mode&=$fd)\n" if $Debug;
        $status = open($self->{fh}, "$mode&=$fd");
    }
    elsif (not ref $fd) {
        warn "fdopen: open(fh, $mode&$fd)\n" if $Debug;
        $status = open($self->{fh}, "$mode&$fd");
    }
    else {
        warn "fdopen: open(fh, $mode&, *$fd)\n" if $Debug;
        $status = open($self->{fh}, "$mode&", *$fd);
    }
    throw Exception::IO
          message => 'Cannot fdopen'
        if not $status;

    # clone standard handler for tied handler
    untie *{ $self->{tied_fh} };
    open $self->{tied_fh}, "$mode&", $self->{fh};
    tie *{ $self->{tied_fh} }, __TIEPACKAGE__, $self;

    return $self;
}


# Standard close IO method
sub close {
    warn "close @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->close'
        if not ref $self;

    CORE::close $self->{fh}
        or throw Exception::IO
                 message => 'Cannot close';

    # close also tied handler
    untie *{ $self->{tied_fh} };
    CORE::close $self->{tied_fh};
    tie *{ $self->{tied_fh} }, __TIEPACKAGE__, $self;

    return $self;
}


# Standard eof IO method
sub eof {
    warn "eof @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->eof'
        if not ref $self;

    return CORE::eof $self->{fh};
}


# Standard fileno IO method
sub fileno {
    warn "fileno @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->fileno'
        if not ref $self;

    return CORE::fileno $self->{fh};
}


sub print {
    warn "print @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->print(ARGS)'
        if not ref $self;

    do {
        # IO modifiers based on object's fields
        local $, = defined $self->{output_field_separator}  ? $self->{output_field_separator}  : $,;
        local $\ = defined $self->{output_record_separator} ? $self->{output_record_separator} : $\;

        # IO modifiers based on tied fh modifiers
        my $oldfh = select $self->{tied_fh};
        my $var = $|;
        select $self->{fh};
        $| = $var;
        select $oldfh;

        CORE::print { $self->{fh} } @_;
    }
    or throw Exception::IO
             message => 'Cannot print';

    return $self;
}


sub printf {
    warn "printf @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->printf(FMT, [ARGS])'
        if not ref $self;

    do {
        # IO modifiers based on tied fh modifiers
        my $oldfh = select $self->{tied_fh};
        my $var = $|;
        select $self->{fh};
        $| = $var;
        select $oldfh;

        CORE::printf { $self->{fh} } @_;
    }
    or throw Exception::IO
             message => 'Cannot printf';

    return $self;
}


sub write {
    warn "write @_" if $Debug;

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->write(BUF [, LEN [, OFFSET]])'
        if not ref $self or @_ > 3 || @_ < 1;

    my ($buf, $len, $offset) = @_;

    do {
        # clean IO modifiers
        local $\ = '';

        # IO modifiers based on tied fh modifiers
        my $oldfh = select $self->{tied_fh};
        my $var = $|;
        select $self->{fh};
        $| = $var;
        select $oldfh;

        CORE::print { $self->{fh} } substr($buf, $offset || 0, defined $len ? $len : length($buf));
    }
    or throw Exception::IO
             message => 'Cannot write';

    return $self;
}


sub format_write {
    warn "format_write @_" if $Debug;

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->format_write([FORMAT_NAME])'
        if not ref $self or @_ > 1;

    my ($fmt) = @_;

    do {
        my ($oldfmt, $oldtopfmt);

        if (defined $fmt) {
            $oldfmt = $self->format_name(qualify($fmt, caller));
            $oldtopfmt = $self->format_top_name(qualify($fmt . '_TOP', caller));
        }

        # IO modifiers based on object's fields
        local $:  = defined $self->{format_line_break_characters} ? $self->{format_line_break_characters} : $:;
        local $^L = defined $self->{format_formfeed}              ? $self->{format_formfeed}              : $^L;

        # IO modifiers based on tied fh modifiers
        my $oldfh = select $self->{tied_fh};
        my @vars = ($|, $%, $=, $-, $~, $^, $.);
        select $self->{fh};
        ($|, $%, $=, $-, $~, $^, $.) = @vars;
        select $oldfh;

        my $status = CORE::write $self->{fh};

        if (defined $fmt) {
            $self->format_name($oldfmt);
            $self->format_top_name($oldtopfmt);
        }

        $status;
    }
    or throw Exception::IO
             message => 'Cannot format_write';

    return $self;
}


sub readline {
    warn "readline @_" if $Debug;

    my $self = shift;

    if (ref $self eq __TIEPACKAGE__) {
        # handle tie hook
        $self = $$self;
    }
    elsif (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->readline'
        if not ref $self or @_ > 0;

    my ($status, @lines, $line, $ungetc_begin, $ungetc_end);

    undef $!;
    {
        # IO modifiers based on object's fields
        local $/ = defined $self->{input_record_separator} ? $self->{input_record_separator} : $/;

        # scalar or array context
        if (wantarray) {
            my (@ungetc_lines, $ungetc_string);
            if ($self->{ungetc_buffer} ne '') {
                # iterate for splitted ungetc buffer
                $ungetc_begin = 0;
                while (($ungetc_end = index $self->{ungetc_buffer}, $/, $ungetc_begin) > -1) {
                    push @ungetc_lines, substr $self->{ungetc_buffer}, $ungetc_begin, $ungetc_end - $ungetc_begin + 1;
                    $ungetc_begin = $ungetc_end + 1;
                }
                # last line of ungetc buffer is also the first line of real readline output
                $ungetc_string = substr $self->{ungetc_buffer}, $ungetc_begin;
            }
            $status = defined(@lines = CORE::readline $self->{fh});
            $lines[0] = $ungetc_string . $lines[0] if defined $lines[0] and $lines[0] ne '';
            unshift @lines, @ungetc_lines if @ungetc_lines;
            chomp @lines if $self->{autochomp};
        }
        else {
            my $ungetc_string;
            if ($self->{ungetc_buffer} ne '') {
                if (($ungetc_end = index $self->{ungetc_buffer}, $/, 0) > -1) {
                    $ungetc_string = substr $self->{ungetc_buffer}, 0, $ungetc_end + 1;
                }
                else {
                    $ungetc_string = $self->{ungetc_buffer};
                }
            }
            if ($ungetc_end > -1) {
                # only ungetc buffer
                $status = 1;
                $line = $ungetc_string;
            }
            else {
                # also call real readline
                $status = defined($line = CORE::readline $self->{fh});
                $line = $ungetc_string . $line;
            }
            chomp $line if $self->{autochomp};
        }
    };
    throw Exception::IO
          message => 'Cannot readline'
        if not $status and $!;

    # clean ungetc buffer
    if ($self->{ungetc_buffer} ne '') {
        if (not wantarray and $ungetc_end > -1) {
            $self->{ungetc_buffer} = substr $self->{ungetc_buffer}, $ungetc_end + 1;
        }
        else {
            $self->{ungetc_buffer} = '';
        }
    }

    return wantarray ? @lines : $line;
}


sub opened {
    warn "opened @_" if $Debug;

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->opened'
        if not ref $self or @_ > 0;

    return defined CORE::fileno $self->{fh};
}


sub getline {
    warn "getline @_" if $Debug;

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->getline'
        if not ref $self or @_ > 0;

    my ($status, $line);

    undef $!;
    {
        # IO modifiers based on object's fields
        local $/ = defined $self->{input_record_separator} ? $self->{input_record_separator} : $/;

        # scalar or array context
        $status = defined($line = scalar CORE::readline $self->{fh});
        chomp $line if $self->{autochomp};
    };
    throw Exception::IO
          message => 'Cannot getline'
        if not $status and $!;

    return $line;
}


sub getlines {
    warn "getlines @_" if $Debug;

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->getlines'
        if not ref $self or @_ > 0;

    throw Exception::BadValue
          message => 'Can\'t call $io->getlines in a scalar context, use $io->getline'
        if not wantarray;

    my ($status, @lines);

    undef $!;
    {
        # IO modifiers based on object's fields
        local $/ = defined $self->{input_record_separator} ? $self->{input_record_separator} : $/;

        # scalar or array context
        $status = defined(@lines = CORE::readline $self->{fh});
        chomp @lines if $self->{autochomp};
    };
    throw Exception::IO
          message => 'Cannot getlines'
        if not $status and $!;

    return @lines;
}


sub ungetc {
    warn "ungetc @_";

    my $self = shift;

    if (reftype $self eq 'GLOB') {
        # handle GLOB reference
        $self = ${*$self};
    }

    throw Exception::BadValue
          message => 'Usage: $io->ungetc(ORD)'
        if not ref $self or @_ != 1;

    my ($ord) = @_;

    $self->{ungetc_buffer} = '' if not defined $self->{ungetc_buffer};
    substr($self->{ungetc_buffer}, 0, 0) = chr($ord);

    return $self;
}


sub __init {
    # Generate accessors for IO modifiers (global and local)
    my %standard_accessors = (
        format_formfeed              => "\014",  # $^L
        format_line_break_characters => ':',     # $:
        input_record_separator       => '/',     # $/
        output_field_separator       => ',',     # $,
        output_record_separator      => '\\',    # $\
    );
    while (my ($func, $var) = each(%standard_accessors)) {
        no strict 'refs';
        *{$func} = sub {
            local *__ANON__ = $func;
            warn "$func @_";
            my $self = shift;
            throw Exception::BadValue
                  message => "Usage: \$io->$func([EXPR])"
                if @_ > 1;
            if (ref $self) {
                $self = ${*$self} if reftype $self eq 'GLOB';
                my $prev = $self->{$func};
                $self->{$func} = shift if @_ > 0;
                return $prev;
            }
            else {
                my $prev = $$var;
                $$var = shift if @_ > 0;
                return $prev;
            }
        };
    }

    # Generate accessors for IO modifiers (output modifiers which require select)
    my %output_accessors = (
        format_lines_left     => '-',  # $-
        format_lines_per_page => '=',  # $=
        format_page_number    => '%',  # $%
        input_line_number     => '.',  # $.
        output_autoflush      => '|',  # $|
    );
    while (my ($func, $var) = each(%output_accessors)) {
        no strict 'refs';
        *{$func} = sub {
            local *__ANON__ = $func;
            warn "$func @_";
            my $self = shift;
            throw Exception::BadValue
                  message => "Usage: \$io->$func([EXPR])"
                if @_ > 1;
            if (ref $self) {
                $self = ${*$self} if reftype $self eq 'GLOB';
                my $oldfh = select $self->{tied_fh};
                my $prev = $$var;
                $$var = shift if @_ > 0;
                select $oldfh;
                return $prev;
            }
            else {
                my $prev = $$var;
                $$var = shift if @_ > 0;
                return $prev;
            }
        };
    }

    # Generate accessors for IO modifiers (qualified format name)
    my %format_name_accessors = (
        format_name      => '~',  # $~
        format_top_name  => '^',  # $^
    );
    while (my ($func, $var) = each(%format_name_accessors)) {
        no strict 'refs';
        *{$func} = sub {
            local *__ANON__ = $func;
            warn "$func @_";
            my $self = shift;
            throw Exception::BadValue
                  message => "Usage: \$io->$func([EXPR])"
                if @_ > 1;
            if (ref $self) {
                $self = ${*$self} if reftype $self eq 'GLOB';
                my $oldfh = select $self->{tied_fh};
                my $prev = $$var;
                $$var = qualify(shift, caller) if @_ > 0;
                select $oldfh;
                return $prev;
            }
            else {
                my $prev = $$var;
                $$var = qualify(shift, caller) if @_ > 0;
                return $prev;
            }
        };
    }

    # Aliases
    *autoflush = \&output_autoflush;

    # Assing tie hooks to real functions
    my @tiefuncs = qw<close eof fileno print printf readline>;
    foreach my $func (@tiefuncs) {
        no strict 'refs';
        *{__PACKAGE__ . '::Tie::' . uc($func)} = \&{__PACKAGE__ . '::' . $func};
    }
}

__init;


# Create anonymous handler
sub anonio {
    my $fh;
    select(select $fh);
    return $fh;
}


sub DESTROY {
    warn "DESTROY @_";
    untie *{ $_[0]->{tied_fh} };
}



package PIPL::IO::Handle::Tie;

use Scalar::Util 'weaken';

our $Debug = 1;


# Create anonymous handler
sub anonio {
    my $fh;
    select(select $fh);
    return $fh;
}


# Tie hook. Others are initialized with __init.
sub TIEHANDLE {
    warn "TIEHANDLE @_";

    my $class = shift;
    my $obj = shift;
    my $self = \$obj;

    # weaken the real object, otherwise it won't be destroyed automatically
    weaken $obj;

    return bless $self => $class;
}


sub OPEN {
    throw Exception::Base message=>"OPEN";
}

sub UNTIE {
    warn "UNTIE @_" if $Debug;
}
sub DESTROY {
    warn "DESTROY @_" if $Debug;
}


1;


=head1 INTERNALS

The main problem is that Perl does not support the indirect notation for IO
object's functions like B<print>, B<close>, etc.

  package My::IO::BadExample;
  sub new { bless {}, $_[0]; }
  sub open { my $self=shift; CORE::open $self->{fh}, @_; }
  sub print { my $self=shift; CORE::print {$self->{fh}} @_; }

  package main;
  my $io = new My::IO::BadExample;
  open $io '>', undef;  # Wrong: missing comma after first argument
  print $io "test";     # Wrong: not GLOB reference

You can use tied handlers:

  $io = \*FOO;
  tie *$io, 'My::IO::Tie';
  open $io, '>', undef;  # see comma after $io: open is just a function
  print $io "test";      # standard indirect notation

The PIPL::IO::Handle object is stored in hash rather than in handler.  The
standard IO functions requires handler as an argument so it won't work.  The
solution is to overload '*{}' dereference operator so it returns the reference
to tied handler.

There are two handlers used for IO operations: the original handler used for IO
operations and tied handler which hooks IO functions interface.

The OO-style uses orignal handler stored in I<fh> field.

  $io->print("OO style");
  ;; package PIPL::IO::Handle;
  ;; sub print { $self=shift; CORE::print {$self->{fh}} @_ }

The IO functions-style uses object reference which is derefered as a handler
tied to proxy object which operates on original handler.

  print $io "IO functions style";
  ;; package PIPL::IO::Handle;
  ;; use overload '*{}' =>, \&deref_handler, fallback => 1;
  ;; sub deref_handler { $self=shift; return $self->{tied_fh} }
  ;; print {$io->{tied_fh}} @_;
  ;; ;; package PIPL::IO::Handle::Tie;
  ;; ;; sub PRINT { $self=shift; $self=$$self; CORE::print {$self->{fh}} @_ }

The I<tied_fh> handler is tied to B<PIPL::IO::Handle::Tie> proxy class.  Its
functions are an alias for B<PIPL::IO::Handle> methods, i.e.
B<PIPL::IO::Handle::Tie::PRINT> is the same as B<PIPL::IO::Handle::print>.
The pure OO classes should be separated but this rule is broken for
performance reason.

The I<tied_fh> handler isn't tied just to B<PIPL::IO::Handle> because
L<Data::Dumper> dumps anonymous handlers poorly and names them with the same
string if they belong to the same class.

=head1 BASE CLASSES

=over 2

=item *

L<PIPL::Class::Base>

=back

=head1 FIELDS

=over

=item fd (rw)

=item mode (rw)

=back

=head1 CONSTRUCTORS

=over

=item new

=back

=head1 METHODS

=over

=item close

=back

=head1 SEE ALSO

L<IO::Handle>, L<PIPL::Class::Base>.

=head1 AUTHORS

Piotr Roszatycki E<lt>dexter@debian.orgE<gt>

=head1 COPYRIGHT

Copyright 2006-2007 by Piotr Roszatycki E<lt>dexter@debian.orgE<gt>.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>
